Usenet 1993 July/InfoMagic USENET CD-ROM July 1993.ISO/sources/misc/volume24/gnucalc/part04

Text File | 1991-10-28 | 55.3 KB | 1,708 lines

Newsgroups: comp.sources.misc
From: [e-mail] (David Gillespie)
Subject:  v24i052:  gnucalc - GNU Emacs Calculator, v2.00, Part04/56
Message-ID: <[e-mail]>
X-Md4-Signature: 79cbb6bf72e1a8e06e57c51a7af51d63
Date: Tue, 29 Oct 1991 04:23:44 GMT
Approved: [e-mail]

Submitted-by: [e-mail] (David Gillespie)
Posting-number: Volume 24, Issue 52
Archive-name: gnucalc/part04
Environment: Emacs
Supersedes: gmcalc: Volume 13, Issue 27-45

---- Cut Here and unpack ----
#!/bin/sh
# this is Part.04 (part 4 of a multipart archive)
# do not concatenate these parts, unpack them in order with /bin/sh
# file calc-aent.el continued
#
if test ! -r _shar_seq_.tmp; then
    echo 'Please unpack part 1 first!'
    exit 1
fi
(read Scheck
 if test "$Scheck" != 4; then
    echo Please unpack part "$Scheck" next!
    exit 1
 else
    exit 0
 fi
) < _shar_seq_.tmp || exit 1
if test ! -f _shar_wnt_.tmp; then
    echo 'x - still skipping calc-aent.el'
else
echo 'x - continuing file calc-aent.el'
sed 's/^X//' << 'SHAR_EOF' >> 'calc-aent.el' &&
X           exp-data (upcase (math-match-substring exp-str 0))
X           exp-pos (match-end 0)))
X        ((and (eq calc-language 'math)
X          (eq (string-match "\\[\\[\\|->\\|:>" exp-str exp-pos)
X              exp-pos))
X         (setq exp-token 'punc
X           exp-data (math-match-substring exp-str 0)
X           exp-pos (match-end 0)))
X        ((and (eq calc-language 'eqn)
X          (eq (string-match "->\\|<-\\|+-\\|\\\\dots\\|~\\|\\^"
X                    exp-str exp-pos)
X              exp-pos))
X         (setq exp-token 'punc
X           exp-data (math-match-substring exp-str 0)
X           exp-pos (match-end 0))
X         (and (eq (string-match "\\\\dots\\." exp-str exp-pos) exp-pos)
X          (setq exp-pos (match-end 0)))
X         (if (memq (aref exp-data 0) '(?~ ?^))
X         (math-read-token)))
X        ((eq (string-match "%%.*$" exp-str exp-pos) exp-pos)
X         (setq exp-pos (match-end 0))
X         (math-read-token))
X        (t
X         (if (and (eq ch ?\{) (memq calc-language '(tex eqn)))
X         (setq ch ?\())
X         (if (and (eq ch ?\}) (memq calc-language '(tex eqn)))
X         (setq ch ?\)))
X         (if (and (eq ch ?\&) (eq calc-language 'tex))
X         (setq ch ?\,))
X         (setq exp-token 'punc
X           exp-data (char-to-string ch)
X           exp-pos (1+ exp-pos))))))
)
X
X
(defun math-read-expr-level (exp-prec)
X  (let* ((x (math-read-factor)) (first t) op op2)
X    (while (and (or (and (setq op (assoc exp-data math-expr-opers))
X             (/= (nth 2 op) -1)
X             (or (and (setq op2 (assoc
X                         exp-data
X                         (cdr (memq op math-expr-opers))))
X                  (eq (= (nth 3 op) -1)
X                      (/= (nth 3 op2) -1))
X                  (eq (= (nth 3 op2) -1)
X                      (not (math-factor-after)))
X                  (setq op op2))
X                 t))
X            (and (or (eq (nth 2 op) -1)
X                 (memq exp-token '(symbol number dollar hash))
X                 (equal exp-data "(")
X                 (and (equal exp-data "[")
X                  (not (eq calc-language 'math))
X                  (not (and exp-keep-spaces
X                        (eq (car-safe x) 'vec)))))
X             (setq op (assoc "2x" math-expr-opers))))
X        (>= (nth 2 op) exp-prec))
X      (if (not (equal (car op) "2x"))
X      (math-read-token))
X      (and (memq (nth 1 op) '(sdev mod))
X       (calc-extensions))
X      (setq x (cond ((consp (nth 1 op))
X             (funcall (car (nth 1 op)) x op))
X            ((eq (nth 3 op) -1)
X             (if (eq (nth 1 op) 'ident)
X             x
X               (if (eq (nth 1 op) 'closing)
X               (if (eq (nth 2 op) exp-prec)
X                   (progn
X                 (setq exp-prec 1000)
X                 x)
X                 (throw 'syntax "Mismatched delimiters"))
X             (list (nth 1 op) x))))
X            ((and (not first)
X              (memq (nth 1 op) math-alg-inequalities)
X              (memq (car-safe x) math-alg-inequalities))
X             (calc-extensions)
X             (math-composite-inequalities x op))
X            (t (list (nth 1 op)
X                 x
X                 (math-read-expr-level (nth 3 op)))))
X        first nil))
X    x)
)
X
(defconst math-alg-inequalities
X  '(calcFunc-lt calcFunc-gt calcFunc-leq calcFunc-geq
X        calcFunc-eq calcFunc-neq))
X
(defun math-remove-dashes (x)
X  (if (string-match "\\`\\(.*\\)-\\(.*\\)\\'" x)
X      (math-remove-dashes
X       (concat (math-match-substring x 1) "#" (math-match-substring x 2)))
X    x)
)
X
(defun math-restore-dashes (x)
X  (if (string-match "\\`\\(.*\\)[#_]\\(.*\\)\\'" x)
X      (math-restore-dashes
X       (concat (math-match-substring x 1) "-" (math-match-substring x 2)))
X    x)
)
X
(defun math-read-if (cond op)
X  (let ((then (math-read-expr-level 0)))
X    (or (equal exp-data ":")
X    (throw 'syntax "Expected ':'"))
X    (math-read-token)
X    (list 'calcFunc-if cond then (math-read-expr-level (nth 3 op))))
)
X
(defun math-factor-after ()
X  (let ((exp-pos exp-pos)
X    exp-old-pos exp-token exp-data)
X    (math-read-token)
X    (or (memq exp-token '(number symbol dollar hash string))
X    (and (assoc exp-data '(("-") ("+") ("!") ("|") ("/")))
X         (assoc (concat "u" exp-data) math-expr-opers))
X    (eq (nth 2 (assoc exp-data math-expr-opers)) -1)
X    (assoc exp-data '(("(") ("[") ("{")))))
)
X
(defun math-read-factor ()
X  (let (op)
X    (cond ((eq exp-token 'number)
X       (let ((num (math-read-number exp-data)))
X         (if (not num)
X         (progn
X           (setq exp-old-pos exp-pos)
X           (throw 'syntax "Bad format")))
X         (math-read-token)
X         (if (and math-read-expr-quotes
X              (consp num))
X         (list 'quote num)
X           num)))
X      ((or (equal exp-data "-")
X           (equal exp-data "+")
X           (equal exp-data "!")
X           (equal exp-data "|")
X           (equal exp-data "/"))
X       (setq exp-data (concat "u" exp-data))
X       (math-read-factor))
X      ((and (setq op (assoc exp-data math-expr-opers))
X        (eq (nth 2 op) -1))
X       (if (consp (nth 1 op))
X           (funcall (car (nth 1 op)) op)
X         (math-read-token)
X         (let ((val (math-read-expr-level (nth 3 op))))
X           (cond ((eq (nth 1 op) 'ident)
X              val)
X             ((and (Math-numberp val)
X               (equal (car op) "u-"))
X              (math-neg val))
X             (t (list (nth 1 op) val))))))
X      ((eq exp-token 'symbol)
X       (let ((sym (intern exp-data)))
X         (math-read-token)
X         (if (equal exp-data calc-function-open)
X         (let ((f (assq sym math-expr-function-mapping)))
X           (math-read-token)
X           (if (consp (cdr f))
X               (funcall (car (cdr f)) f sym)
X             (let ((args (if (or (equal exp-data calc-function-close)
X                     (eq exp-token 'end))
X                     nil
X                   (math-read-expr-list))))
X               (if (not (or (equal exp-data calc-function-close)
X                    (eq exp-token 'end)))
X               (throw 'syntax "Expected `)'"))
X               (math-read-token)
X               (if f
X               (setq sym (cdr f))
X             (and (= (aref (symbol-name sym) 0) ?\\)
X                  (< (prefix-numeric-value calc-language-option) 0)
X                  (setq sym (intern (substring (symbol-name sym)
X                               1))))
X             (or (string-match "-" (symbol-name sym))
X                 (setq sym (intern (concat "calcFunc-"
X                               (symbol-name sym))))))
X               (cons sym args))))
X           (if math-read-expr-quotes
X           sym
X         (let ((val (list 'var
X                  (intern (math-remove-dashes
X                       (symbol-name sym)))
X                  (if (string-match "-" (symbol-name sym))
X                      sym
X                    (intern (concat "var-"
X                            (symbol-name sym)))))))
X           (let ((v (assq (nth 1 val) math-expr-variable-mapping)))
X             (and v (setq val (if (consp (cdr v))
X                      (funcall (car (cdr v)) v val)
X                    (list 'var
X                          (intern
X                           (substring (symbol-name (cdr v))
X                              4))
X                          (cdr v))))))
X           (while (and (memq calc-language '(c pascal maple))
X                   (equal exp-data "["))
X             (math-read-token)
X             (setq val (append (list 'calcFunc-subscr val)
X                       (math-read-expr-list)))
X             (if (equal exp-data "]")
X             (math-read-token)
X               (throw 'syntax "Expected ']'")))
X           val)))))
X      ((eq exp-token 'dollar)
X       (if (>= (length calc-dollar-values) (math-abs exp-data))
X           (let ((num exp-data))
X         (math-read-token)
X         (setq calc-dollar-used (max calc-dollar-used num))
X         (math-check-complete (nth (1- (math-abs num))
X                       calc-dollar-values)))
X         (throw 'syntax (if calc-dollar-values
X                "Too many $'s"
X                  "$'s not allowed in this context"))))
X      ((eq exp-token 'hash)
X       (or calc-hashes-used
X           (throw 'syntax "#'s not allowed in this context"))
X       (calc-extensions)
X       (if (<= exp-data (length calc-arg-values))
X           (let ((num exp-data))
X         (math-read-token)
X         (setq calc-hashes-used (max calc-hashes-used num))
X         (nth (1- num) calc-arg-values))
X         (throw 'syntax "Too many # arguments")))
X      ((equal exp-data "(")
X       (let* ((exp (let ((exp-keep-spaces nil))
X             (math-read-token)
X             (if (or (equal exp-data "\\dots")
X                 (equal exp-data "\\ldots"))
X                 '(neg (var inf var-inf))
X               (math-read-expr-level 0)))))
X         (let ((exp-keep-spaces nil))
X           (cond
X        ((equal exp-data ",")
X         (progn
X           (math-read-token)
X           (let ((exp2 (math-read-expr-level 0)))
X             (setq exp
X               (if (and exp2 (Math-realp exp) (Math-realp exp2))
X                   (math-normalize (list 'cplx exp exp2))
X                 (list '+ exp (list '* exp2 '(var i var-i))))))))
X        ((equal exp-data ";")
X         (progn
X           (math-read-token)
X           (let ((exp2 (math-read-expr-level 0)))
X             (setq exp (if (and exp2 (Math-realp exp)
X                    (Math-anglep exp2))
X                   (math-normalize (list 'polar exp exp2))
X                 (calc-extensions)
X                 (list '* exp
X                       (list 'calcFunc-exp
X                         (list '*
X                           (math-to-radians-2 exp2)
X                           '(var i var-i)))))))))
X        ((or (equal exp-data "\\dots")
X             (equal exp-data "\\ldots"))
X         (progn
X           (math-read-token)
X           (let ((exp2 (if (or (equal exp-data ")")
X                       (equal exp-data "]")
X                       (eq exp-token 'end))
X                   '(var inf var-inf)
X                 (math-read-expr-level 0))))
X             (setq exp
X               (list 'intv
X                 (if (equal exp-data ")") 0 1)
X                 exp
X                 exp2)))))))
X         (if (not (or (equal exp-data ")")
X              (and (equal exp-data "]") (eq (car-safe exp) 'intv))
X              (eq exp-token 'end)))
X         (throw 'syntax "Expected `)'"))
X         (math-read-token)
X         exp))
X      ((eq exp-token 'string)
X       (calc-extensions)
X       (math-read-string))
X      ((equal exp-data "[")
X       (calc-extensions)
X       (math-read-brackets t "]"))
X      ((equal exp-data "{")
X       (calc-extensions)
X       (math-read-brackets nil "}"))
X      ((equal exp-data "<")
X       (calc-extensions)
X       (math-read-angle-brackets))
X      (t (throw 'syntax "Expected a number"))))
)
X
X
X
SHAR_EOF
echo 'File calc-aent.el is complete' &&
chmod 0644 calc-aent.el ||
echo 'restore of calc-aent.el failed'
Wc_c="`wc -c < 'calc-aent.el'`"
test 28616 -eq "$Wc_c" ||
    echo 'calc-aent.el: original size 28616, current size' "$Wc_c"
rm -f _shar_wnt_.tmp
fi
# ============= calc-alg-2.el ==============
if test -f 'calc-alg-2.el' -a X"$1" != X"-c"; then
    echo 'x - skipping calc-alg-2.el (File already exists)'
    rm -f _shar_wnt_.tmp
else
> _shar_wnt_.tmp
echo 'x - extracting calc-alg-2.el (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'calc-alg-2.el' &&
;; Calculator for GNU Emacs, part II [calc-alg-2.el]
;; Copyright (C) 1990, 1991 Free Software Foundation, Inc.
;; Written by Dave Gillespie, [e-mail].
X
;; This file is part of GNU Emacs.
X
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY.  No author or distributor
;; accepts responsibility to anyone for the consequences of using it
;; or for whether it serves any particular purpose or works at all,
;; unless he says so in writing.  Refer to the GNU Emacs General Public
;; License for full details.
X
;; Everyone is granted permission to copy, modify and redistribute
;; GNU Emacs, but only under the conditions described in the
;; GNU Emacs General Public License.   A copy of this license is
;; supposed to have been given to you along with GNU Emacs so you
;; can know your rights and responsibilities.  It should be in a
;; file named COPYING.  Among other things, the copyright notice
;; and this notice must be preserved on all copies.
X
X
X
;; This file is autoloaded from calc-ext.el.
(require 'calc-ext)
X
(require 'calc-macs)
X
(defun calc-Need-calc-alg-2 () nil)
X
X
(defun calc-derivative (var num)
X  (interactive "sDifferentiate with respect to: \np")
X  (calc-slow-wrapper
X   (and (< num 0) (error "Order of derivative must be positive"))
X   (let ((func (if (calc-is-hyperbolic) 'calcFunc-tderiv 'calcFunc-deriv))
X     n expr)
X     (if (or (equal var "") (equal var "$"))
X     (setq n 2
X           expr (calc-top-n 2)
X           var (calc-top-n 1))
X       (setq var (math-read-expr var))
X       (if (eq (car-safe var) 'error)
X       (error "Bad format in expression: %s" (nth 1 var)))
X       (setq n 1
X         expr (calc-top-n 1)))
X     (while (>= (setq num (1- num)) 0)
X       (setq expr (list func expr var)))
X     (calc-enter-result n "derv" expr)))
)
X
(defun calc-integral (var)
X  (interactive "sIntegration variable: ")
X  (calc-slow-wrapper
X   (if (or (equal var "") (equal var "$"))
X       (calc-enter-result 2 "intg" (list 'calcFunc-integ
X                     (calc-top-n 2)
X                     (calc-top-n 1)))
X     (let ((var (math-read-expr var)))
X       (if (eq (car-safe var) 'error)
X       (error "Bad format in expression: %s" (nth 1 var)))
X       (calc-enter-result 1 "intg" (list 'calcFunc-integ
X                     (calc-top-n 1)
X                     var)))))
)
X
(defun calc-num-integral (&optional varname lowname highname)
X  (interactive "sIntegration variable: ")
X  (calc-tabular-command 'calcFunc-ninteg "Integration" "nint"
X            nil varname lowname highname)
)
X
(defun calc-summation (arg &optional varname lowname highname)
X  (interactive "P\nsSummation variable: ")
X  (calc-tabular-command 'calcFunc-sum "Summation" "sum"
X            arg varname lowname highname)
)
X
(defun calc-alt-summation (arg &optional varname lowname highname)
X  (interactive "P\nsSummation variable: ")
X  (calc-tabular-command 'calcFunc-asum "Summation" "asum"
X            arg varname lowname highname)
)
X
(defun calc-product (arg &optional varname lowname highname)
X  (interactive "P\nsIndex variable: ")
X  (calc-tabular-command 'calcFunc-prod "Index" "prod"
X            arg varname lowname highname)
)
X
(defun calc-tabulate (arg &optional varname lowname highname)
X  (interactive "P\nsIndex variable: ")
X  (calc-tabular-command 'calcFunc-table "Index" "tabl"
X            arg varname lowname highname)
)
X
(defun calc-tabular-command (func prompt prefix arg varname lowname highname)
X  (calc-slow-wrapper
X   (let (var (low nil) (high nil) (step nil) stepname stepnum (num 1) expr)
X     (if (consp arg)
X     (setq stepnum 1)
X       (setq stepnum 0))
X     (if (or (equal varname "") (equal varname "$") (null varname))
X     (setq high (calc-top-n (+ stepnum 1))
X           low (calc-top-n (+ stepnum 2))
X           var (calc-top-n (+ stepnum 3))
X           num (+ stepnum 4))
X       (setq var (if (stringp varname) (math-read-expr varname) varname))
X       (if (eq (car-safe var) 'error)
X       (error "Bad format in expression: %s" (nth 1 var)))
X       (or lowname
X       (setq lowname (read-string (concat prompt " variable: " varname
X                          ", from: "))))
X       (if (or (equal lowname "") (equal lowname "$"))
X       (setq high (calc-top-n (+ stepnum 1))
X         low (calc-top-n (+ stepnum 2))
X         num (+ stepnum 3))
X     (setq low (if (stringp lowname) (math-read-expr lowname) lowname))
X     (if (eq (car-safe low) 'error)
X         (error "Bad format in expression: %s" (nth 1 low)))
X     (or highname
X         (setq highname (read-string (concat prompt " variable: " varname
X                         ", from: " lowname
X                         ", to: "))))
X     (if (or (equal highname "") (equal highname "$"))
X         (setq high (calc-top-n (+ stepnum 1))
X           num (+ stepnum 2))
X       (setq high (if (stringp highname) (math-read-expr highname)
X            highname))
X       (if (eq (car-safe high) 'error)
X           (error "Bad format in expression: %s" (nth 1 high)))
X       (if (consp arg)
X           (progn
X         (setq stepname (read-string (concat prompt " variable: "
X                             varname
X                             ", from: " lowname
X                             ", to: " highname
X                             ", step: ")))
X         (if (or (equal stepname "") (equal stepname "$"))
X             (setq step (calc-top-n 1)
X               num 2)
X           (setq step (math-read-expr stepname))
X           (if (eq (car-safe step) 'error)
X               (error "Bad format in expression: %s"
X                  (nth 1 step)))))))))
X     (or step
X     (if (consp arg)
X         (setq step (calc-top-n 1))
X       (if arg
X           (setq step (prefix-numeric-value arg)))))
X     (setq expr (calc-top-n num))
X     (calc-enter-result num prefix (append (list func expr var low high)
X                       (and step (list step))))))
)
X
(defun calc-solve-for (var)
X  (interactive "sVariable to solve for: ")
X  (calc-slow-wrapper
X   (let ((func (if (calc-is-inverse)
X           (if (calc-is-hyperbolic) 'calcFunc-ffinv 'calcFunc-finv)
X         (if (calc-is-hyperbolic) 'calcFunc-fsolve 'calcFunc-solve))))
X     (if (or (equal var "") (equal var "$"))
X     (calc-enter-result 2 "solv" (list func
X                       (calc-top-n 2)
X                       (calc-top-n 1)))
X       (let ((var (if (and (string-match ",\\|[^ ] +[^ ]" var)
X               (not (string-match "\\[" var)))
X              (math-read-expr (concat "[" var "]"))
X            (math-read-expr var))))
X     (if (eq (car-safe var) 'error)
X         (error "Bad format in expression: %s" (nth 1 var)))
X     (calc-enter-result 1 "solv" (list func
X                       (calc-top-n 1)
X                       var))))))
)
X
(defun calc-poly-roots (var)
X  (interactive "sVariable to solve for: ")
X  (calc-slow-wrapper
X   (if (or (equal var "") (equal var "$"))
X       (calc-enter-result 2 "prts" (list 'calcFunc-roots
X                     (calc-top-n 2)
X                     (calc-top-n 1)))
X     (let ((var (if (and (string-match ",\\|[^ ] +[^ ]" var)
X             (not (string-match "\\[" var)))
X            (math-read-expr (concat "[" var "]"))
X          (math-read-expr var))))
X       (if (eq (car-safe var) 'error)
X       (error "Bad format in expression: %s" (nth 1 var)))
X       (calc-enter-result 1 "prts" (list 'calcFunc-roots
X                     (calc-top-n 1)
X                     var)))))
)
X
(defun calc-taylor (var nterms)
X  (interactive "sTaylor expansion variable: \nNNumber of terms: ")
X  (calc-slow-wrapper
X   (let ((var (math-read-expr var)))
X     (if (eq (car-safe var) 'error)
X     (error "Bad format in expression: %s" (nth 1 var)))
X     (calc-enter-result 1 "tylr" (list 'calcFunc-taylor
X                       (calc-top-n 1)
X                       var
X                       (prefix-numeric-value nterms)))))
)
X
X
(defun math-derivative (expr)   ; uses global values: deriv-var, deriv-total.
X  (cond ((equal expr deriv-var)
X     1)
X    ((or (Math-scalarp expr)
X         (eq (car expr) 'sdev)
X         (and (eq (car expr) 'var)
X          (or (not deriv-total)
X              (math-const-var expr)
X              (progn
X            (math-setup-declarations)
X            (memq 'const (nth 1 (or (assq (nth 2 expr)
X                              math-decls-cache)
X                        math-decls-all)))))))
X     0)
X    ((eq (car expr) '+)
X     (math-add (math-derivative (nth 1 expr))
X           (math-derivative (nth 2 expr))))
X    ((eq (car expr) '-)
X     (math-sub (math-derivative (nth 1 expr))
X           (math-derivative (nth 2 expr))))
X    ((memq (car expr) '(calcFunc-eq calcFunc-neq calcFunc-lt
X                    calcFunc-gt calcFunc-leq calcFunc-geq))
X     (list (car expr)
X           (math-derivative (nth 1 expr))
X           (math-derivative (nth 2 expr))))
X    ((eq (car expr) 'neg)
X     (math-neg (math-derivative (nth 1 expr))))
X    ((eq (car expr) '*)
X     (math-add (math-mul (nth 2 expr)
X                 (math-derivative (nth 1 expr)))
X           (math-mul (nth 1 expr)
X                 (math-derivative (nth 2 expr)))))
X    ((eq (car expr) '/)
X     (math-sub (math-div (math-derivative (nth 1 expr))
X                 (nth 2 expr))
X           (math-div (math-mul (nth 1 expr)
X                       (math-derivative (nth 2 expr)))
X                 (math-sqr (nth 2 expr)))))
X    ((eq (car expr) '^)
X     (let ((du (math-derivative (nth 1 expr)))
X           (dv (math-derivative (nth 2 expr))))
X       (or (Math-zerop du)
X           (setq du (math-mul (nth 2 expr)
X                  (math-mul (math-normalize
X                         (list '^
X                           (nth 1 expr)
X                           (math-add (nth 2 expr) -1)))
X                        du))))
X       (or (Math-zerop dv)
X           (setq dv (math-mul (math-normalize
X                   (list 'calcFunc-ln (nth 1 expr)))
X                  (math-mul expr dv))))
X       (math-add du dv)))
X    ((eq (car expr) '%)
X     (math-derivative (nth 1 expr)))   ; a reasonable definition
X    ((eq (car expr) 'vec)
X     (math-map-vec 'math-derivative expr))
X    ((and (memq (car expr) '(calcFunc-conj calcFunc-re calcFunc-im))
X          (= (length expr) 2))
X     (list (car expr) (math-derivative (nth 1 expr))))
X    ((and (memq (car expr) '(calcFunc-subscr calcFunc-mrow calcFunc-mcol))
X          (= (length expr) 3))
X     (let ((d (math-derivative (nth 1 expr))))
X       (if (math-numberp d)
X           0    ; assume x and x_1 are independent vars
X         (list (car expr) d (nth 2 expr)))))
X    (t (or (and (symbolp (car expr))
X            (if (= (length expr) 2)
X            (let ((handler (get (car expr) 'math-derivative)))
X              (and handler
X                   (let ((deriv (math-derivative (nth 1 expr))))
X                 (if (Math-zerop deriv)
X                     deriv
X                   (math-mul (funcall handler (nth 1 expr))
X                         deriv)))))
X              (let ((handler (get (car expr) 'math-derivative-n)))
X            (and handler
X                 (funcall handler expr)))))
X           (and (not (eq deriv-symb 'pre-expand))
X            (let ((exp (math-expand-formula expr)))
X              (and exp
X               (or (let ((deriv-symb 'pre-expand))
X                 (catch 'math-deriv (math-derivative expr)))
X                   (math-derivative exp)))))
X           (if (or (Math-objvecp expr)
X               (eq (car expr) 'var)
X               (not (symbolp (car expr))))
X           (if deriv-symb
X               (throw 'math-deriv nil)
X             (list (if deriv-total 'calcFunc-tderiv 'calcFunc-deriv)
X               expr
X               deriv-var))
X         (let ((accum 0)
X               (arg expr)
X               (n 1)
X               derv)
X           (while (setq arg (cdr arg))
X             (or (Math-zerop (setq derv (math-derivative (car arg))))
X             (let ((func (intern (concat (symbol-name (car expr))
X                             "'"
X                             (if (> n 1)
X                             (int-to-string n)
X                               ""))))
X                   (prop (cond ((= (length expr) 2)
X                        'math-derivative-1)
X                       ((= (length expr) 3)
X                        'math-derivative-2)
X                       ((= (length expr) 4)
X                        'math-derivative-3)
X                       ((= (length expr) 5)
X                        'math-derivative-4)
X                       ((= (length expr) 6)
X                        'math-derivative-5))))
X               (setq accum
X                 (math-add
X                  accum
X                  (math-mul
X                   derv
X                   (let ((handler (get func prop)))
X                     (or (and prop handler
X                          (apply handler (cdr expr)))
X                     (if (and deriv-symb
X                          (not (get func
X                                'calc-user-defn)))
X                         (throw 'math-deriv nil)
X                       (cons func (cdr expr))))))))))
X             (setq n (1+ n)))
X           accum)))))
)
X
(defun calcFunc-deriv (expr deriv-var &optional deriv-value deriv-symb)
X  (let* ((deriv-total nil)
X     (res (catch 'math-deriv (math-derivative expr))))
X    (or (eq (car-safe res) 'calcFunc-deriv)
X    (null res)
X    (setq res (math-normalize res)))
X    (and res
X     (if deriv-value
X         (math-expr-subst res deriv-var deriv-value)
X       res)))
)
X
(defun calcFunc-tderiv (expr deriv-var &optional deriv-value deriv-symb)
X  (math-setup-declarations)
X  (let* ((deriv-total t)
X     (res (catch 'math-deriv (math-derivative expr))))
X    (or (eq (car-safe res) 'calcFunc-tderiv)
X    (null res)
X    (setq res (math-normalize res)))
X    (and res
X     (if deriv-value
X         (math-expr-subst res deriv-var deriv-value)
X       res)))
)
X
(put 'calcFunc-inv\' 'math-derivative-1
X     (function (lambda (u) (math-neg (math-div 1 (math-sqr u))))))
X
(put 'calcFunc-sqrt\' 'math-derivative-1
X     (function (lambda (u) (math-div 1 (math-mul 2 (list 'calcFunc-sqrt u))))))
X
(put 'calcFunc-deg\' 'math-derivative-1
X     (function (lambda (u) (math-div-float '(float 18 1) (math-pi)))))
X
(put 'calcFunc-rad\' 'math-derivative-1
X     (function (lambda (u) (math-pi-over-180))))
X
(put 'calcFunc-ln\' 'math-derivative-1
X     (function (lambda (u) (math-div 1 u))))
X
(put 'calcFunc-log10\' 'math-derivative-1
X     (function (lambda (u)
X         (math-div (math-div 1 (math-normalize '(calcFunc-ln 10)))
X               u))))
X
(put 'calcFunc-lnp1\' 'math-derivative-1
X     (function (lambda (u) (math-div 1 (math-add u 1)))))
X
(put 'calcFunc-log\' 'math-derivative-2
X     (function (lambda (x b)
X         (and (not (Math-zerop b))
X              (let ((lnv (math-normalize
X                  (list 'calcFunc-ln b))))
X            (math-div 1 (math-mul lnv x)))))))
X
(put 'calcFunc-log\'2 'math-derivative-2
X     (function (lambda (x b)
X         (let ((lnv (list 'calcFunc-ln b)))
X           (math-neg (math-div (list 'calcFunc-log x b)
X                       (math-mul lnv b)))))))
X
(put 'calcFunc-exp\' 'math-derivative-1
X     (function (lambda (u) (math-normalize (list 'calcFunc-exp u)))))
X
(put 'calcFunc-expm1\' 'math-derivative-1
X     (function (lambda (u) (math-normalize (list 'calcFunc-expm1 u)))))
X
(put 'calcFunc-sin\' 'math-derivative-1
X     (function (lambda (u) (math-to-radians-2 (math-normalize
X                           (list 'calcFunc-cos u))))))
X
(put 'calcFunc-cos\' 'math-derivative-1
X     (function (lambda (u) (math-neg (math-to-radians-2
X                      (math-normalize
X                       (list 'calcFunc-sin u)))))))
X
(put 'calcFunc-tan\' 'math-derivative-1
X     (function (lambda (u) (math-to-radians-2
X                (math-div 1 (math-sqr
X                     (math-normalize
X                      (list 'calcFunc-cos u))))))))
X
(put 'calcFunc-arcsin\' 'math-derivative-1
X     (function (lambda (u)
X         (math-from-radians-2
X          (math-div 1 (math-normalize
X                   (list 'calcFunc-sqrt
X                     (math-sub 1 (math-sqr u)))))))))
X
(put 'calcFunc-arccos\' 'math-derivative-1
X     (function (lambda (u)
X         (math-from-radians-2
X          (math-div -1 (math-normalize
X                (list 'calcFunc-sqrt
X                      (math-sub 1 (math-sqr u)))))))))
X
(put 'calcFunc-arctan\' 'math-derivative-1
X     (function (lambda (u) (math-from-radians-2
X                (math-div 1 (math-add 1 (math-sqr u)))))))
X
(put 'calcFunc-sinh\' 'math-derivative-1
X     (function (lambda (u) (math-normalize (list 'calcFunc-cosh u)))))
X
(put 'calcFunc-cosh\' 'math-derivative-1
X     (function (lambda (u) (math-normalize (list 'calcFunc-sinh u)))))
X
(put 'calcFunc-tanh\' 'math-derivative-1
X     (function (lambda (u) (math-div 1 (math-sqr
X                    (math-normalize
X                     (list 'calcFunc-cosh u)))))))
X
(put 'calcFunc-arcsinh\' 'math-derivative-1
X     (function (lambda (u)
X         (math-div 1 (math-normalize
X                  (list 'calcFunc-sqrt
X                    (math-add (math-sqr u) 1)))))))
X
(put 'calcFunc-arccosh\' 'math-derivative-1
X     (function (lambda (u)
X          (math-div 1 (math-normalize
X                   (list 'calcFunc-sqrt
X                     (math-add (math-sqr u) -1)))))))
X
(put 'calcFunc-arctanh\' 'math-derivative-1
X     (function (lambda (u) (math-div 1 (math-sub 1 (math-sqr u))))))
X
(put 'calcFunc-bern\'2 'math-derivative-2
X     (function (lambda (n x)
X         (math-mul n (list 'calcFunc-bern (math-add n -1) x)))))
X
(put 'calcFunc-euler\'2 'math-derivative-2
X     (function (lambda (n x)
X         (math-mul n (list 'calcFunc-euler (math-add n -1) x)))))
X
(put 'calcFunc-gammag\'2 'math-derivative-2
X     (function (lambda (a x) (math-deriv-gamma a x 1))))
X
(put 'calcFunc-gammaG\'2 'math-derivative-2
X     (function (lambda (a x) (math-deriv-gamma a x -1))))
X
(put 'calcFunc-gammaP\'2 'math-derivative-2
X     (function (lambda (a x) (math-deriv-gamma a x
X                           (math-div
X                        1 (math-normalize
X                           (list 'calcFunc-gamma
X                             a)))))))
X
(put 'calcFunc-gammaQ\'2 'math-derivative-2
X     (function (lambda (a x) (math-deriv-gamma a x
X                           (math-div
X                        -1 (math-normalize
X                            (list 'calcFunc-gamma
X                              a)))))))
X
(defun math-deriv-gamma (a x scale)
X  (math-mul scale
X        (math-mul (math-pow x (math-add a -1))
X              (list 'calcFunc-exp (math-neg x))))
)
X
(put 'calcFunc-betaB\' 'math-derivative-3
X     (function (lambda (x a b) (math-deriv-beta x a b 1))))
X
(put 'calcFunc-betaI\' 'math-derivative-3
X     (function (lambda (x a b) (math-deriv-beta x a b
X                        (math-div
X                         1 (list 'calcFunc-beta
X                             a b))))))
X
(defun math-deriv-beta (x a b scale)
X  (math-mul (math-mul (math-pow x (math-add a -1))
X              (math-pow (math-sub 1 x) (math-add b -1)))
X        scale)
)
X
(put 'calcFunc-erf\' 'math-derivative-1
X     (function (lambda (x) (math-div 2
X                     (math-mul (list 'calcFunc-exp
X                             (math-sqr x))
X                           (if calc-symbolic-mode
X                           '(calcFunc-sqrt
X                             (var pi var-pi))
X                         (math-sqrt-pi)))))))
X
(put 'calcFunc-erfc\' 'math-derivative-1
X     (function (lambda (x) (math-div -2
X                     (math-mul (list 'calcFunc-exp
X                             (math-sqr x))
X                           (if calc-symbolic-mode
X                           '(calcFunc-sqrt
X                             (var pi var-pi))
X                         (math-sqrt-pi)))))))
X
(put 'calcFunc-besJ\'2 'math-derivative-2
X     (function (lambda (v z) (math-div (math-sub (list 'calcFunc-besJ
X                               (math-add v -1)
X                               z)
X                         (list 'calcFunc-besJ
X                               (math-add v 1)
X                               z))
X                       2))))
X
(put 'calcFunc-besY\'2 'math-derivative-2
X     (function (lambda (v z) (math-div (math-sub (list 'calcFunc-besY
X                               (math-add v -1)
X                               z)
X                         (list 'calcFunc-besY
X                               (math-add v 1)
X                               z))
X                       2))))
X
(put 'calcFunc-sum 'math-derivative-n
X     (function
X      (lambda (expr)
X    (if (math-expr-contains (cons 'vec (cdr (cdr expr))) deriv-var)
X        (throw 'math-deriv nil)
X      (cons 'calcFunc-sum
X        (cons (math-derivative (nth 1 expr))
X              (cdr (cdr expr))))))))
X
(put 'calcFunc-prod 'math-derivative-n
X     (function
X      (lambda (expr)
X    (if (math-expr-contains (cons 'vec (cdr (cdr expr))) deriv-var)
X        (throw 'math-deriv nil)
X      (math-mul expr
X            (cons 'calcFunc-sum
X              (cons (math-div (math-derivative (nth 1 expr))
X                      (nth 1 expr))
X                (cdr (cdr expr)))))))))
X
(put 'calcFunc-integ 'math-derivative-n
X     (function
X      (lambda (expr)
X    (if (= (length expr) 3)
X        (if (equal (nth 2 expr) deriv-var)
X        (nth 1 expr)
X          (math-normalize
X           (list 'calcFunc-integ
X             (math-derivative (nth 1 expr))
X             (nth 2 expr))))
X      (if (= (length expr) 5)
X          (let ((lower (math-expr-subst (nth 1 expr) (nth 2 expr)
X                        (nth 3 expr)))
X            (upper (math-expr-subst (nth 1 expr) (nth 2 expr)
X                        (nth 4 expr))))
X        (math-add (math-sub (math-mul upper
X                          (math-derivative (nth 4 expr)))
X                    (math-mul lower
X                          (math-derivative (nth 3 expr))))
X              (if (equal (nth 2 expr) deriv-var)
X                  0
X                (math-normalize
X                 (list 'calcFunc-integ
X                   (math-derivative (nth 1 expr)) (nth 2 expr)
X                   (nth 3 expr) (nth 4 expr)))))))))))
X
(put 'calcFunc-if 'math-derivative-n
X     (function
X      (lambda (expr)
X    (and (= (length expr) 4)
X         (list 'calcFunc-if (nth 1 expr)
X           (math-derivative (nth 2 expr))
X           (math-derivative (nth 3 expr)))))))
X
(put 'calcFunc-subscr 'math-derivative-n
X     (function
X      (lambda (expr)
X    (and (= (length expr) 3)
X         (list 'calcFunc-subscr (nth 1 expr)
X           (math-derivative (nth 2 expr)))))))
X
X
X
X
X
(setq math-integ-var '(var X ---))
(setq math-integ-var-2 '(var Y ---))
(setq math-integ-vars (list 'f math-integ-var math-integ-var-2))
(setq math-integ-var-list (list math-integ-var))
(setq math-integ-var-list-list (list math-integ-var-list))
X
(defmacro math-tracing-integral (&rest parts)
X  (list 'and
X    'trace-buffer
X    (list 'save-excursion
X          '(set-buffer trace-buffer)
X          '(goto-char (point-max))
X          (list 'and
X            '(bolp)
X            '(insert (make-string (- math-integral-limit
X                         math-integ-level) 32)
X                 (format "%2d " math-integ-depth)
X                 (make-string math-integ-level 32)))
X          (cons 'insert parts)
X          '(sit-for 0)))
)
X
;;; The following wrapper caches results and avoids infinite recursion.
;;; Each cache entry is: ( A B )          Integral of A is B;
;;;             ( A N )          Integral of A failed at level N;
;;;             ( A busy )      Currently working on integral of A;
;;;             ( A parts )      Currently working, integ-by-parts;
;;;             ( A parts2 )      Currently working, integ-by-parts;
;;;             ( A cancelled )  Ignore this cache entry;
;;;             ( A [B] )        Same result as for cur-record = B.
(defun math-integral (expr &optional simplify same-as-above)
X  (let* ((simp cur-record)
X     (cur-record (assoc expr math-integral-cache))
X     (math-integ-depth (1+ math-integ-depth))
X     (val 'cancelled))
X    (math-tracing-integral "Integrating "
X               (math-format-value expr 1000)
X               "...\n")
X    (and cur-record
X     (progn
X       (math-tracing-integral "Found "
X                  (math-format-value (nth 1 cur-record) 1000))
X       (and (consp (nth 1 cur-record))
X        (math-replace-integral-parts cur-record))
X       (math-tracing-integral " => "
X                  (math-format-value (nth 1 cur-record) 1000)
X                  "\n")))
X    (or (and cur-record
X         (not (eq (nth 1 cur-record) 'cancelled))
X         (or (not (integerp (nth 1 cur-record)))
X         (>= (nth 1 cur-record) math-integ-level)))
X    (and (math-integral-contains-parts expr)
X         (progn
X           (setq val nil)
X           t))
X    (unwind-protect
X        (progn
X          (let (math-integ-msg)
X        (if (eq calc-display-working-message 'lots)
X            (progn
X              (calc-set-command-flag 'clear-message)
X              (setq math-integ-msg (format
X                        "Working... Integrating %s"
X                        (math-format-flat-expr expr 0)))
X              (message math-integ-msg)))
X        (if cur-record
X            (setcar (cdr cur-record)
X                (if same-as-above (vector simp) 'busy))
X          (setq cur-record
X            (list expr (if same-as-above (vector simp) 'busy))
X            math-integral-cache (cons cur-record
X                          math-integral-cache)))
X        (if (eq simplify 'yes)
X            (progn
X              (math-tracing-integral "Simplifying...")
X              (setq simp (math-simplify expr))
X              (setq val (if (equal simp expr)
X                    (progn
X                      (math-tracing-integral " no change\n")
X                      (math-do-integral expr))
X                  (math-tracing-integral " simplified\n")
X                  (math-integral simp 'no t))))
X          (or (setq val (math-do-integral expr))
X              (eq simplify 'no)
X              (let ((simp (math-simplify expr)))
X            (or (equal simp expr)
X                (progn
X                  (math-tracing-integral "Trying again after "
X                             "simplification...\n")
X                  (setq val (math-integral simp 'no t))))))))
X          (if (eq calc-display-working-message 'lots)
X          (message math-integ-msg)))
X      (setcar (cdr cur-record) (or val
X                       (if (or math-enable-subst
X                           (not math-any-substs))
X                       math-integ-level
X                     'cancelled)))))
X    (setq val cur-record)
X    (while (vectorp (nth 1 val))
X      (setq val (aref (nth 1 val) 0)))
X    (setq val (if (memq (nth 1 val) '(parts parts2))
X          (progn
X            (setcar (cdr val) 'parts2)
X            (list 'var 'PARTS val))
X        (and (consp (nth 1 val))
X             (nth 1 val))))
X    (math-tracing-integral "Integral of "
X               (math-format-value expr 1000)
X               "  is  "
X               (math-format-value val 1000)
X               "\n")
X    val)
)
(defvar math-integral-cache nil)
(defvar math-integral-cache-state nil)
X
(defun math-integral-contains-parts (expr)
X  (if (Math-primp expr)
X      (and (eq (car-safe expr) 'var)
X       (eq (nth 1 expr) 'PARTS)
X       (listp (nth 2 expr)))
X    (while (and (setq expr (cdr expr))
X        (not (math-integral-contains-parts (car expr)))))
X    expr)
)
X
(defun math-replace-integral-parts (expr)
X  (or (Math-primp expr)
X      (while (setq expr (cdr expr))
X    (and (consp (car expr))
X         (if (eq (car (car expr)) 'var)
X         (and (eq (nth 1 (car expr)) 'PARTS)
X              (consp (nth 2 (car expr)))
X              (if (listp (nth 1 (nth 2 (car expr))))
X              (progn
X                (setcar expr (nth 1 (nth 2 (car expr))))
X                (math-replace-integral-parts (cons 'foo expr)))
X            (setcar (cdr cur-record) 'cancelled)))
X           (math-replace-integral-parts (car expr))))))
)
X
(defun math-do-integral (expr)
X  (let (t1 t2)
X    (or (cond ((not (math-expr-contains expr math-integ-var))
X           (math-mul expr math-integ-var))
X          ((equal expr math-integ-var)
X           (math-div (math-sqr expr) 2))
X          ((eq (car expr) '+)
X           (and (setq t1 (math-integral (nth 1 expr)))
X            (setq t2 (math-integral (nth 2 expr)))
X            (math-add t1 t2)))
X          ((eq (car expr) '-)
X           (and (setq t1 (math-integral (nth 1 expr)))
X            (setq t2 (math-integral (nth 2 expr)))
X            (math-sub t1 t2)))
X          ((eq (car expr) 'neg)
X           (and (setq t1 (math-integral (nth 1 expr)))
X            (math-neg t1)))
X          ((eq (car expr) '*)
X           (cond ((not (math-expr-contains (nth 1 expr) math-integ-var))
X              (and (setq t1 (math-integral (nth 2 expr)))
X               (math-mul (nth 1 expr) t1)))
X             ((not (math-expr-contains (nth 2 expr) math-integ-var))
X              (and (setq t1 (math-integral (nth 1 expr)))
X               (math-mul t1 (nth 2 expr))))
X             ((memq (car-safe (nth 1 expr)) '(+ -))
X              (math-integral (list (car (nth 1 expr))
X                       (math-mul (nth 1 (nth 1 expr))
X                             (nth 2 expr))
X                       (math-mul (nth 2 (nth 1 expr))
X                             (nth 2 expr)))
X                     'yes t))
X             ((memq (car-safe (nth 2 expr)) '(+ -))
X              (math-integral (list (car (nth 2 expr))
X                       (math-mul (nth 1 (nth 2 expr))
X                             (nth 1 expr))
X                       (math-mul (nth 2 (nth 2 expr))
X                             (nth 1 expr)))
X                     'yes t))))
X          ((eq (car expr) '/)
X           (cond ((and (not (math-expr-contains (nth 1 expr)
X                            math-integ-var))
X               (not (math-equal-int (nth 1 expr) 1)))
X              (and (setq t1 (math-integral (math-div 1 (nth 2 expr))))
X               (math-mul (nth 1 expr) t1)))
X             ((not (math-expr-contains (nth 2 expr) math-integ-var))
X              (and (setq t1 (math-integral (nth 1 expr)))
X               (math-div t1 (nth 2 expr))))
X             ((and (eq (car-safe (nth 1 expr)) '*)
X               (not (math-expr-contains (nth 1 (nth 1 expr))
X                            math-integ-var)))
X              (and (setq t1 (math-integral
X                     (math-div (nth 2 (nth 1 expr))
X                           (nth 2 expr))))
X               (math-mul t1 (nth 1 (nth 1 expr)))))
X             ((and (eq (car-safe (nth 2 expr)) '*)
X               (not (math-expr-contains (nth 1 (nth 2 expr))
X                            math-integ-var)))
X              (and (setq t1 (math-integral
X                     (math-div (nth 1 expr)
X                           (nth 2 (nth 2 expr)))))
X               (math-div t1 (nth 1 (nth 2 expr)))))))
X          ((eq (car expr) '^)
X           (cond ((not (math-expr-contains (nth 1 expr) math-integ-var))
X              (or (and (setq t1 (math-is-polynomial (nth 2 expr)
X                                math-integ-var 1))
X                   (math-div expr
X                     (math-mul (nth 1 t1)
X                           (math-normalize
X                            (list 'calcFunc-ln
X                              (nth 1 expr))))))
X              (math-integral
X               (list 'calcFunc-exp
X                 (math-mul (nth 2 expr)
X                       (math-normalize
X                        (list 'calcFunc-ln
X                          (nth 1 expr)))))
X               'yes t)))
X             ((not (math-expr-contains (nth 2 expr) math-integ-var))
X              (if (and (integerp (nth 2 expr)) (< (nth 2 expr) 0))
X              (math-integral
X               (list '/ 1 (math-pow (nth 1 expr) (- (nth 2 expr))))
X               nil t)
X            (or (and (setq t1 (math-is-polynomial (nth 1 expr)
X                                  math-integ-var
X                                  1))
X                 (setq t2 (math-add (nth 2 expr) 1))
X                 (math-div (math-pow (nth 1 expr) t2)
X                       (math-mul t2 (nth 1 t1))))
X                (and (Math-negp (nth 2 expr))
X                 (math-integral
X                  (math-div 1
X                        (math-pow (nth 1 expr)
X                              (math-neg
X                               (nth 2 expr))))
X                  nil t))
X                nil))))))
X
X    ;; Integral of a polynomial.
X    (and (setq t1 (math-is-polynomial expr math-integ-var 20))
X         (let ((accum 0)
X           (n 1))
X           (while t1
X         (if (setq accum (math-add accum
X                       (math-div (math-mul (car t1)
X                                   (math-pow
X                                math-integ-var
X                                n))
X                             n))
X               t1 (cdr t1))
X             (setq n (1+ n))))
X           accum))
X
X    ;; Try looking it up!
X    (cond ((= (length expr) 2)
X           (and (symbolp (car expr))
X            (setq t1 (get (car expr) 'math-integral))
X            (progn
X              (while (and t1
X                  (not (setq t2 (funcall (car t1)
X                             (nth 1 expr)))))
X            (setq t1 (cdr t1)))
X              (and t2 (math-normalize t2)))))
X          ((= (length expr) 3)
X           (and (symbolp (car expr))
X            (setq t1 (get (car expr) 'math-integral-2))
X            (progn
X              (while (and t1
X                  (not (setq t2 (funcall (car t1)
X                             (nth 1 expr)
X                             (nth 2 expr)))))
X            (setq t1 (cdr t1)))
X              (and t2 (math-normalize t2))))))
X
X    ;; Integral of a rational function.
X    (and (math-ratpoly-p expr math-integ-var)
X         (setq t1 (calcFunc-apart expr math-integ-var))
X         (not (equal t1 expr))
X         (math-integral t1))
X
X    ;; Try user-defined integration rules.
X    (and (calc-has-rules 'var-IntegRules)
X         (let ((math-old-integ (symbol-function 'calcFunc-integ))
X           (input (list 'calcFunc-integtry expr math-integ-var))
X           res part)
X           (unwind-protect
X           (progn
X             (fset 'calcFunc-integ 'math-sub-integration)
X             (setq res (math-rewrite input
X                         '(var IntegRules var-IntegRules)
X                         1))
X             (fset 'calcFunc-integ math-old-integ)
X             (and (not (equal res input))
X              (if (setq part (math-expr-calls
X                      res '(calcFunc-integsubst)))
X                  (and (memq (length part) '(3 4 5))
X                   (let ((parts (mapcar
X                         (function
X                          (lambda (x)
X                            (math-expr-subst
X                             x (nth 2 part)
X                             math-integ-var)))
X                         (cdr part))))
X                     (math-integrate-by-substitution
X                      expr (car parts) t
X                      (or (nth 2 parts)
X                      (list 'calcFunc-integfailed
X                        math-integ-var))
X                      (nth 3 parts))))
X                (if (not (math-expr-calls res
X                              '(calcFunc-integtry
X                            calcFunc-integfailed)))
X                res))))
X         (fset 'calcFunc-integ math-old-integ))))
X
X    ;; See if the function is a symbolic derivative.
X    (and (string-match "'" (symbol-name (car expr)))
X         (let ((name (symbol-name (car expr)))
X           (p expr) (n 0) (which nil) (bad nil))
X           (while (setq n (1+ n) p (cdr p))
X         (if (equal (car p) math-integ-var)
X             (if which (setq bad t) (setq which n))
X           (if (math-expr-contains (car p) math-integ-var)
X               (setq bad t))))
X           (and which (not bad)
X            (let ((prime (if (= which 1) "'" (format "'%d" which))))
X              (and (string-match (concat prime "\\('['0-9]*\\|$\\)")
X                     name)
X               (cons (intern
X                  (concat
X                   (substring name 0 (match-beginning 0))
X                   (substring name (+ (match-beginning 0)
X                              (length prime)))))
X                 (cdr expr)))))))
X
X    ;; Try transformation methods (parts, substitutions).
X    (and (> math-integ-level 0)
X         (math-do-integral-methods expr))
X
X    ;; Try expanding the function's definition.
X    (let ((res (math-expand-formula expr)))
X      (and res
X           (math-integral res)))))
)
X
(defun math-sub-integration (expr &rest rest)
X  (or (if (or (not rest)
X          (and (< math-integ-level math-integral-limit)
X           (eq (car rest) math-integ-var)))
X      (math-integral expr)
X    (let ((res (apply math-old-integ expr rest)))
X      (and (or (= math-integ-level math-integral-limit)
X           (not (math-expr-calls res 'calcFunc-integ)))
X           res)))
X      (list 'calcFunc-integfailed expr))
)
X
(defun math-do-integral-methods (expr)
X  (let ((so-far math-integ-var-list-list)
X    rat-in)
X
X    ;; Integration by substitution, for various likely sub-expressions.
X    ;; (In first pass, we look only for sub-exprs that are linear in X.)
X    (or (if math-enable-subst
X        (math-integ-try-substitutions expr)
X      (math-integ-try-linear-substitutions expr))
X
X    ;; If function has sines and cosines, try tan(x/2) substitution.
X    (and (let ((p (setq rat-in (math-expr-rational-in expr))))
X           (while (and p
X               (memq (car (car p)) '(calcFunc-sin
X                         calcFunc-cos
X                         calcFunc-tan))
X               (equal (nth 1 (car p)) math-integ-var))
X         (setq p (cdr p)))
X           (null p))
X         (or (and (math-integ-parts-easy expr)
X              (math-integ-try-parts expr t))
X         (math-integrate-by-good-substitution
X          expr (list 'calcFunc-tan (math-div math-integ-var 2)))))
X
X    ;; If function has sinh and cosh, try tanh(x/2) substitution.
X    (and (let ((p rat-in))
X           (while (and p
X               (memq (car (car p)) '(calcFunc-sinh
X                         calcFunc-cosh
X                         calcFunc-tanh
X                         calcFunc-exp))
X               (equal (nth 1 (car p)) math-integ-var))
X         (setq p (cdr p)))
X           (null p))
X         (or (and (math-integ-parts-easy expr)
X              (math-integ-try-parts expr t))
X         (math-integrate-by-good-substitution
X          expr (list 'calcFunc-tanh (math-div math-integ-var 2)))))
X
X    ;; If function has square roots, try sin, tan, or sec substitution.
X    (and (let ((p rat-in))
X           (setq t1 nil)
X           (while (and p
X               (or (equal (car p) math-integ-var)
X                   (and (eq (car (car p)) 'calcFunc-sqrt)
X                    (setq t1 (math-is-polynomial
X                          (nth 1 (setq t2 (car p)))
X                          math-integ-var 2)))))
X         (setq p (cdr p)))
X           (and (null p) t1))
X         (if (cdr (cdr t1))
X         (if (math-guess-if-neg (nth 2 t1))
X             (let* ((c (math-sqrt (math-neg (nth 2 t1))))
X                (d (math-div (nth 1 t1) (math-mul -2 c)))
X                (a (math-sqrt (math-add (car t1) (math-sqr d)))))
X               (math-integrate-by-good-substitution
X            expr (list 'calcFunc-arcsin
X                   (math-div-thru
X                    (math-add (math-mul c math-integ-var) d)
X                    a))))
X           (let* ((c (math-sqrt (nth 2 t1)))
X              (d (math-div (nth 1 t1) (math-mul 2 c)))
X              (aa (math-sub (car t1) (math-sqr d))))
X             (if (and nil (not (and (eq d 0) (eq c 1))))
X             (math-integrate-by-good-substitution
X              expr (math-add (math-mul c math-integ-var) d))
X               (if (math-guess-if-neg aa)
X               (math-integrate-by-good-substitution
X                expr (list 'calcFunc-arccosh
X                       (math-div-thru
X                    (math-add (math-mul c math-integ-var)
X                          d)
X                    (math-sqrt (math-neg aa)))))
X             (math-integrate-by-good-substitution
X              expr (list 'calcFunc-arcsinh
X                     (math-div-thru
X                      (math-add (math-mul c math-integ-var)
X                        d)
X                      (math-sqrt aa))))))))
X           (math-integrate-by-good-substitution expr t2)) )
X
X    ;; Try integration by parts.
X    (math-integ-try-parts expr)
X
X    ;; Give up.
X    nil))
)
X
(defun math-integ-parts-easy (expr)
X  (cond ((Math-primp expr) t)
X    ((memq (car expr) '(+ - *))
X     (and (math-integ-parts-easy (nth 1 expr))
X          (math-integ-parts-easy (nth 2 expr))))
X    ((eq (car expr) '/)
X     (and (math-integ-parts-easy (nth 1 expr))
X          (math-atomic-factorp (nth 2 expr))))
X    ((eq (car expr) '^)
X     (and (natnump (nth 2 expr))
X          (math-integ-parts-easy (nth 1 expr))))
X    ((eq (car expr) 'neg)
X     (math-integ-parts-easy (nth 1 expr)))
X    (t t))
)
X
(defun math-integ-try-parts (expr &optional math-good-parts)
X  ;; Integration by parts:
X  ;;   integ(f(x) g(x),x) = f(x) h(x) - integ(h(x) f'(x),x)
X  ;;     where h(x) = integ(g(x),x).
X  (or (let ((exp (calcFunc-expand expr)))
X    (and (not (equal exp expr))
X         (math-integral exp)))
X      (and (eq (car expr) '*)
X       (let ((first-bad (or (math-polynomial-p (nth 1 expr)
X                           math-integ-var)
X                (equal (nth 2 expr) math-prev-parts-v))))
X         (or (and first-bad   ; so try this one first
X              (math-integrate-by-parts (nth 1 expr) (nth 2 expr)))
X         (math-integrate-by-parts (nth 2 expr) (nth 1 expr))
X         (and (not first-bad)
X              (math-integrate-by-parts (nth 1 expr) (nth 2 expr))))))
X      (and (eq (car expr) '/)
X       (math-expr-contains (nth 1 expr) math-integ-var)
X       (let ((recip (math-div 1 (nth 2 expr))))
X         (or (math-integrate-by-parts (nth 1 expr) recip)
X         (math-integrate-by-parts recip (nth 1 expr)))))
X      (and (eq (car expr) '^)
X       (math-integrate-by-parts (math-pow (nth 1 expr)
X                          (math-sub (nth 2 expr) 1))
X                    (nth 1 expr))))
)
X
(defun math-integrate-by-parts (u vprime)
X  (let ((math-integ-level (if (or math-good-parts
X                  (math-polynomial-p u math-integ-var))
X                  math-integ-level
X                (1- math-integ-level)))
X    (math-doing-parts t)
X    v temp)
X    (and (>= math-integ-level 0)
X     (unwind-protect
X         (progn
X           (setcar (cdr cur-record) 'parts)
X           (math-tracing-integral "Integrating by parts, u = "
X                      (math-format-value u 1000)
X                      ", v' = "
X                      (math-format-value vprime 1000)
X                      "\n")
X           (and (setq v (math-integral vprime))
X            (setq temp (calcFunc-deriv u math-integ-var nil t))
X            (setq temp (let ((math-prev-parts-v v))
X                 (math-integral (math-mul v temp) 'yes)))
X            (setq temp (math-sub (math-mul u v) temp))
X            (if (eq (nth 1 cur-record) 'parts)
X            (calcFunc-expand temp)
X              (setq v (list 'var 'PARTS cur-record)
X                var-thing (list 'vec (math-sub v temp) v)
X                temp (let (calc-next-why)
X                   (math-solve-for (math-sub v temp) 0 v nil)))
X              (and temp (not (integerp temp))
X               (math-simplify-extended temp)))))
X       (setcar (cdr cur-record) 'busy))))
)
X
;;; This tries two different formulations, hoping the algebraic simplifier
;;; will be strong enough to handle at least one.
(defun math-integrate-by-substitution (expr u &optional user uinv uinvprime)
X  (and (> math-integ-level 0)
X       (let ((math-integ-level (max (- math-integ-level 2) 0)))
X     (math-integrate-by-good-substitution expr u user uinv uinvprime)))
)
X
(defun math-integrate-by-good-substitution (expr u &optional user
X                         uinv uinvprime)
X  (let ((math-living-dangerously t)
X    deriv temp)
X    (and (setq uinv (if uinv
X            (math-expr-subst uinv math-integ-var
X                     math-integ-var-2)
X              (let (calc-next-why)
X            (math-solve-for u
X                    math-integ-var-2
X                    math-integ-var nil))))
X     (progn
X       (math-tracing-integral "Integrating by substitution, u = "
X                  (math-format-value u 1000)
X                  "\n")
X       (or (and (setq deriv (calcFunc-deriv u
X                        math-integ-var nil
X                        (not user)))
X            (setq temp (math-integral (math-expr-subst
X                           (math-expr-subst
X                        (math-expr-subst
X                         (math-div expr deriv)
X                         u
X                         math-integ-var-2)
X                        math-integ-var
X                        uinv)
X                           math-integ-var-2
X                           math-integ-var)
X                          'yes)))
X           (and (setq deriv (or uinvprime
X                    (calcFunc-deriv uinv
X                            math-integ-var-2
X                            math-integ-var
X                            (not user))))
X            (setq temp (math-integral (math-mul
X                           (math-expr-subst
X                        (math-expr-subst
X                         (math-expr-subst
X                          expr
X                          u
X                          math-integ-var-2)
X                         math-integ-var
X                         uinv)
X                        math-integ-var-2
X                        math-integ-var)
X                           deriv)
X                          'yes)))))
X     (math-simplify-extended
X      (math-expr-subst temp math-integ-var u))))
)
X
;;; Look for substitutions of the form u = a x + b.
(defun math-integ-try-linear-substitutions (sub-expr)
X  (and (not (Math-primp sub-expr))
X       (or (and (not (memq (car sub-expr) '(+ - * / neg)))
X        (not (and (eq (car sub-expr) '^)
X              (integerp (nth 2 sub-expr))))
X        (math-expr-contains sub-expr math-integ-var)
X        (let ((res nil))
X          (while (and (setq sub-expr (cdr sub-expr))
X                  (or (not (math-linear-in (car sub-expr)
X                               math-integ-var))
X                  (assoc (car sub-expr) so-far)
X                  (progn
X                    (setq so-far (cons (list (car sub-expr))
X                               so-far))
X                    (not (setq res
X                           (math-integrate-by-substitution
X                        expr (car sub-expr))))))))
X          res))
X       (let ((res nil))
X         (while (and (setq sub-expr (cdr sub-expr))
X             (not (setq res (math-integ-try-linear-substitutions
X                     (car sub-expr))))))
X         res)))
)
X
;;; Recursively try different substitutions based on various sub-expressions.
(defun math-integ-try-substitutions (sub-expr &optional allow-rat)
X  (and (not (Math-primp sub-expr))
X       (not (assoc sub-expr so-far))
X       (math-expr-contains sub-expr math-integ-var)
X       (or (and (if (and (not (memq (car sub-expr) '(+ - * / neg)))
X             (not (and (eq (car sub-expr) '^)
X                   (integerp (nth 2 sub-expr)))))
X            (prog1 allow-rat (setq allow-rat nil))
X          (setq allow-rat t))
X        (not (eq sub-expr expr))
X        (math-integrate-by-substitution expr sub-expr))
X       (let ((res nil))
X         (setq so-far (cons (list sub-expr) so-far))
X         (while (and (setq sub-expr (cdr sub-expr))
X             (not (setq res (math-integ-try-substitutions
X                     (car sub-expr) allow-rat)))))
X         res)))
)
X
(defun math-expr-rational-in (expr)
X  (let ((parts nil))
X    (math-expr-rational-in-rec expr)
X    (mapcar 'car parts))
)
X
(defun math-expr-rational-in-rec (expr)
X  (cond ((Math-primp expr)
X     (and (equal expr math-integ-var)
X          (not (assoc expr parts))
X          (setq parts (cons (list expr) parts))))
X    ((or (memq (car expr) '(+ - * / neg))
X         (and (eq (car expr) '^) (integerp (nth 2 expr))))
X     (math-expr-rational-in-rec (nth 1 expr))
X     (and (nth 2 expr) (math-expr-rational-in-rec (nth 2 expr))))
X    ((and (eq (car expr) '^)
X          (eq (math-quarter-integer (nth 2 expr)) 2))
X     (math-expr-rational-in-rec (list 'calcFunc-sqrt (nth 1 expr))))
X    (t
X     (and (not (assoc expr parts))
X          (math-expr-contains expr math-integ-var)
X          (setq parts (cons (list expr) parts)))))
)
X
(defun math-expr-calls (expr funcs &optional arg-contains)
X  (if (consp expr)
X      (if (or (memq (car expr) funcs)
X          (and (eq (car expr) '^) (eq (car funcs) 'calcFunc-sqrt)
X           (eq (math-quarter-integer (nth 2 expr)) 2)))
X      (and (or (not arg-contains)
X           (math-expr-contains expr arg-contains))
X           expr)
X    (and (not (Math-primp expr))
X         (let ((res nil))
X           (while (and (setq expr (cdr expr))
X               (not (setq res (math-expr-calls
X                       (car expr) funcs arg-contains)))))
X           res))))
)
X
(defun math-fix-const-terms (expr except-vars)
X  (cond ((not (math-expr-depends expr except-vars)) 0)
X    ((Math-primp expr) expr)
X    ((eq (car expr) '+)
X     (math-add (math-fix-const-terms (nth 1 expr) except-vars)
X           (math-fix-const-terms (nth 2 expr) except-vars)))
X    ((eq (car expr) '-)
X     (math-sub (math-fix-const-terms (nth 1 expr) except-vars)
X           (math-fix-const-terms (nth 2 expr) except-vars)))
X    (t expr))
)
X
;; Command for debugging the Calculator's symbolic integrator.
(defun calc-dump-integral-cache (&optional arg)
X  (interactive "P")
X  (let ((buf (current-buffer)))
X    (unwind-protect
X    (let ((p math-integral-cache)
X          cur-record)
X      (display-buffer (get-buffer-create "*Integral Cache*"))
X      (set-buffer (get-buffer "*Integral Cache*"))
X      (erase-buffer)
X      (while p
X        (setq cur-record (car p))
X        (or arg (math-replace-integral-parts cur-record))
X        (insert (math-format-flat-expr (car cur-record) 0)
X            " --> "
X            (if (symbolp (nth 1 cur-record))
X            (concat "(" (symbol-name (nth 1 cur-record)) ")")
X              (math-format-flat-expr (nth 1 cur-record) 0))
X            "\n")
X        (setq p (cdr p)))
X      (goto-char (point-min)))
X      (set-buffer buf)))
)
X
(defun math-try-integral (expr)
X  (let ((math-integ-level math-integral-limit)
X    (math-integ-depth 0)
X    (math-integ-msg "Working...done")
X    (cur-record nil)   ; a technicality
X    (math-integrating t)
X    (calc-prefer-frac t)
X    (calc-symbolic-mode t))
X    (or (math-integral expr 'yes)
X    (and math-any-substs
X         (setq math-enable-subst t)
X         (math-integral expr 'yes))
X    (and (> math-max-integral-limit math-integral-limit)
X         (setq math-integral-limit math-max-integral-limit
X           math-integ-level math-integral-limit)
X         (math-integral expr 'yes))))
)
X
(defun calcFunc-integ (expr var &optional low high)
X  (cond
X   ;; Do these even if the parts turn out not to be integrable.
X   ((eq (car-safe expr) '+)
X    (math-add (calcFunc-integ (nth 1 expr) var low high)
X          (calcFunc-integ (nth 2 expr) var low high)))
X   ((eq (car-safe expr) '-)
X    (math-sub (calcFunc-integ (nth 1 expr) var low high)
X          (calcFunc-integ (nth 2 expr) var low high)))
X   ((eq (car-safe expr) 'neg)
X    (math-neg (calcFunc-integ (nth 1 expr) var low high)))
X   ((and (eq (car-safe expr) '*)
X     (not (math-expr-contains (nth 1 expr) var)))
X    (math-mul (nth 1 expr) (calcFunc-integ (nth 2 expr) var low high)))
X   ((and (eq (car-safe expr) '*)
SHAR_EOF
true || echo 'restore of calc-alg-2.el failed'
fi
echo 'End of  part 4'
echo 'File calc-alg-2.el is continued in part 5'
echo 5 > _shar_seq_.tmp
exit 0
exit 0 # Just in case...
--
Kent Landfield                   INTERNET: [e-mail]
Sterling Software, IMD           UUCP:     uunet!sparky!kent
Phone:    [phone]         FAX:      [phone]
Please send comp.sources.misc-related mail to [e-mail].